home *** CD-ROM | disk | FTP | other *** search
/ BMUG Revelations / BMUG Revelations.toast / Programming / Programming Languages / XLisp 2.1e3 / lisp / turtle.lsp < prev    next >
Lisp/Scheme  |  1993-05-18  |  2KB  |  89 lines
  1. ; turtle.lsp for MacXLisp 2.1e by Tom Almy and Brian Kendig
  2. ;
  3. ; A set of turtle graphics primitives (a la Logo)
  4. ; to demonstrate XLisp's drawing routines.
  5. ;
  6. ; Originally by Peter Ashwood-Smith.  Bugs fixed by Tom Almy.
  7. ; Rewritten for MacXLisp by Brian Kendig.
  8.  
  9. (defun pause (secs) 
  10.   (let ((finish (+ (get-internal-run-time)
  11.                    (* secs internal-time-units-per-second))))
  12.         (loop (when (> (get-internal-run-time) finish)
  13.                 (return-from pause)))))
  14.  
  15. ; Primitives
  16.  
  17. (defun TurtleInit nil
  18.   (setq CenterX 100 CenterY 100)
  19.   (showgraphics)
  20.   (cleargraphics)
  21.   (TurtleCenter))
  22.  
  23. (defun TurtleCenter nil
  24.   (moveto CenterX CenterY)
  25.   (setq Heading 0))
  26.  
  27. (defun TurtleGoto (x y)
  28.   (moveto x y)) 
  29.  
  30. (defun TurtleRight (deg)
  31.   (setq Heading (- Heading (* deg 0.01745329))))
  32.  
  33. (defun TurtleLeft (deg)
  34.   (setq Heading (+ Heading (* deg 0.01745329))))
  35.  
  36. (defun TurtleForward (dist)
  37.   (draw (truncate (* (cos Heading) dist))
  38.         (truncate (* (sin Heading) dist))))
  39.  
  40. (defun PenDown nil (showpen))
  41. (defun PenUp nil (hidepen))
  42.  
  43. ; Demonstrations
  44.  
  45. (defun Line_T (size)        
  46.     (TurtleForward size) (TurtleRight 180)
  47.     (TurtleForward (/ size 4)))
  48.     
  49. (defun Square (size)
  50.   (TurtleForward size)  (TurtleRight 90)     
  51.   (TurtleForward size)  (TurtleRight 90)     
  52.   (TurtleForward size)  (TurtleRight 90)     
  53.   (TurtleForward size))
  54.  
  55. (defun Triangle (size)
  56.   (TurtleForward size)  (TurtleRight 120)
  57.   (TurtleForward size)  (TurtleRight 120)
  58.   (TurtleForward size))
  59.  
  60. (defun Make (ObjectFunc Size star skew)
  61.   (dotimes (dummy star)
  62.     (apply ObjectFunc (list Size))
  63.     (TurtleRight skew)))
  64.  
  65. (defun GraphicsDemo nil
  66.        (TurtleInit)
  67.        (color 65535 0 0)
  68.        (Make #'Square 40 18 5) (Make #'Square 60 30 5)
  69.        (pause 3)
  70.        (TurtleInit)
  71.        (color 0 65535 0) (Make #'Triangle 60 30 5)
  72.        (color 50000 0 0) (Make #'Triangle 40 30 5)
  73.        (pause 3)
  74.        (TurtleInit)
  75.        (color 0 0 65535)
  76.        (Make #'Line_T 80 50 10)
  77.        (pause 3)
  78.        (TurtleInit)
  79.        (setq red 60000 green 0 blue 30000 step 2000)
  80.        (dotimes (dummy 60)
  81.          (color red green blue)
  82.          (Square 60) (TurtleRight 5)
  83.          (setq red (- red step)
  84.                blue (+ blue step))))
  85.  
  86. (print "Try (GraphicsDemo)")
  87.  
  88. ;(setq *features* (cons :turtle *features*))
  89.